home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Celestin Apprentice 7
/
Apprentice-Release7.iso
/
Environments
/
PowerLisp 2.01
/
PowerLisp 2.01 ƒ
/
Library
/
loop.lisp
< prev
next >
Wrap
Text File
|
1996-05-17
|
55KB
|
1,500 lines
;;; LOOP -*- Mode:LISP; Syntax:Common-Lisp; Package:(LOOP (COMMON-LISP); Base:10; Lowercase:T -*-
;;; **********************************************************************
;;; ****** Common Lisp ******** LOOP Iteration Macro *********************
;;; **********************************************************************
;;; **** (C) COPYRIGHT 1980, 1981 MASSACHUSETTS INSTITUTE OF TECHNOLOGY **
;;; ******** THIS IS A READ-ONLY FILE! (ALL WRITES RESERVED) *************
;;; **********************************************************************
;;;
;;;
;;;; LOOP Iteration Macro
;;; This is the "officially sanctioned" version of LOOP for running in
;;; Common Lisp. It is a conversion of LOOP 829, which is fairly close to
;;; that released with Symbolics Release 6.1 (803). This conversion was
;;; made by Glenn Burke (one of the original author/maintainers); the
;;; work was performed at Palladian Software, in Cambridge MA, April 1986.
;;;
;;; The current version of this file will be maintained at MIT, available
;;; for anonymous FTP on MC.LCS.MIT.EDU from the file "LSB1;CLLOOP >". This
;;; location will no doubt change sometime in the future.
;;;
;;; This file, like the LOOP it is derived from, has unrestricted
;;; distribution -- anyone may take it and use it. But for the sake of
;;; consistency, bug reporting, compatibility, and users' sanity, PLEASE
;;; PLEASE PLEASE don't go overboard with fixes or changes. Remember that
;;; this version is supposed to be compatible with the Maclisp/Zetalisp/NIL
;;; LOOP; it is NOT intended to be "different" or "better" or "redesigned".
;;; Report bugs and propose fixes to BUG-LOOP@MC.LCS.MIT.EDU;
;;; announcements about LOOP will be made to the mailing list
;;; INFO-LOOP@MC.LCS.MIT.EDU. Mail concerning those lists (such as requests
;;; to be added) should be sent to the BUG-LOOP-REQUEST and
;;; INFO-LOOP-REQUEST lists respectively. Note the Change History page
;;; below...
;;;
;;; LOOP documentation is still probably available from the MIT Laboratory
;;; for Computer Science publications office:
;;; LCS Publications
;;; 545 Technology Square
;;; Cambridge, MA 02139
;;; It is Technical Memo 169, "LOOP Iteration Macro", and is very old. The
;;; most up-to-date documentation on this version of LOOP is that in the NIL
;;; Reference Manual (TR-311 from LCS Publications); while you wouldn't
;;; want to get that (it costs nearly $15) just for LOOP documentation,
;;; those with access to a NIL manual might photocopy the chapter on LOOP.
;;; That revised documentation can be reissued as a revised technical memo
;;; if there is sufficient demand.
;;;
;;;; Change History
;;; Roger Corman 15-May-96 Minor modifications for use with PowerLisp 2.0.
;;; jbs@think.com 10-Oct-86 I removed the &environment code so this would work for KCL
;;; [gsb@palladian] 30-apr-86 00:26 File Created from NIL's LOOP version 829
;;;------------------------------------------------------------------------
;;;------- End of official change history -- note local fixes below -------
;;;------------------------------------------------------------------------
;;;
;;;
;;; bill@cambridge.apple.com 06/14/91 loop-for-arithmetic no longer assumes fixnum
;;; -------------- 2.0b2
;;; bill@cambridge.apple.com 03/04/91 string-length -> length
;;;--------------- 2.0b1
;;; bill@cambridge.apple.com 12/10/90 Add CL: prefix to the initial defpackage & in-package forms
;;; bill@cambridge.apple.com 09/28/90 define-loop-macro call goes after def of loop-translate
;;; to eliminate compiler warnings.
;;; bill@cambridge.apple.com 09/07/90 PROVIDE goes at the end of the file!
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Package setup
;;;The following symbols are documented as being available via SI:. Far be
;;;it for us to define a package by that name, however we can do the
;;;following. We will create a "loop-si-kludge" package (sounds like a
;;;fairly safe name), import the SI: symbols from there into LOOP, export
;;;them, define that people (use-package 'loop), and if they want to
;;;maintain source compatibility they can add the SI nickname the
;;;loop-si-kludge package. How's that?
;(in-package 'loop-si-kludge)
;(export '(loop-tequal loop-tassoc loop-tmember loop-use-system-destructuring?
; loop-named-variable loop-simplep loop-simplep-1
; loop-sequencer loop-sequence-elements-path))
;(cl:defpackage loop (:use common-lisp))
;(cl:in-package :loop)
(eval-when (:load-toplevel :compile-toplevel :execute)
(provide :loop)
(in-package :loop) ; no defpackage yet RGC
)
;(use-package '(loop-si-kludge))
;shadow?
;(shadow '(loop loop-finish define-loop-macro define-loop-path
; define-loop-sequence-path))
;
;(shadow '(loop-tequal loop-tassoc loop-tmember loop-use-system-destructuring?
; loop-named-variable loop-simplep loop-simplep-1
; loop-sequencer loop-sequence-elements-path))
;(shadow '(loop:lisp)) wrong! AHR howard
(shadow '(loop) 'common-lisp) ; No shadow functions yet -- RGC
(export '(loop loop-finish define-loop-macro define-loop-path
define-loop-sequence-path))
(export '(loop-tequal loop-tassoc loop-tmember loop-use-system-destructuring?
loop-named-variable loop-simplep loop-simplep-1
loop-sequencer loop-sequence-elements-path))
;require?
;;;; Macro Environment Setup
; Hack up the stuff for data-types. DATA-TYPE? will always be a macro
; so that it will not require the data-type package at run time if
; all uses of the other routines are conditionalized upon that value.
(eval-when (eval compile)
; Crock for DATA-TYPE? derives from DTDCL. We just copy it rather
; than load it in, which requires knowing where it comes from (sigh).
;
(defmacro data-type? (frob)
(let ((foo (gensym)))
`((lambda (,foo)
;; NIL croaks if nil given to GET... No it doesn't any more! But:
;; Every Lisp should (but doesn't) croak if randomness given to GET
;; LISPM croaks (of course) if randomness given to get-pname
(and (symbolp ,foo)
(or (get ,foo ':data-type)
(and (setq ,foo (find-symbol (symbol-name ,foo) (find-package 'keyword)))
(get ,foo ':data-type)))))
,frob)))
)
;;; The uses of this macro are retained in the CL version of loop, in case they are
;;; needed in a particular implementation. Originally dating from the use of the
;;; Zetalisp COPYLIST* function, this is used in situations where, were cdr-coding
;;; in use, having cdr-NIL at the end of the list might be suboptimal because the
;;; end of the list will probably be RPLACDed and so cdr-normal should be used instead.
(defmacro loop-copylist* (l)
`(copy-list ,l))
;;;; Random Macros
(defmacro loop-simple-error (unquoted-message &optional (datum nil datump))
`(error ,(if datump "LOOP: ~S ~A" "LOOP: ~A")
',unquoted-message ,@(and datump (list datum))))
(defmacro loop-warn (unquoted-message &optional (datum nil datump))
(if datump
`(warn ,(concatenate 'string "LOOP: " unquoted-message " -- ~{~S~^ ~}")
,datum)
`(warn ',(concatenate 'string "LOOP: " unquoted-message))))
;; (defmacro loop-pop-source () '(pop loop-source-code)) ;; RGC
(defun loop-pop-source ()
(if loop-source-code
(pop loop-source-code)
(error "LOOP source code ran out when another token was expected.")))
(defmacro loop-gentemp (&optional (pref ''loopvar-))
`(gentemp (symbol-name ,pref)))
;;;; Setq Hackery
; Note: LOOP-MAKE-PSETQ is NOT flushable depending on the existence
; of PSETQ, unless PSETQ handles destructuring. Even then it is
; preferable for the code LOOP produces to not contain intermediate
; macros, especially in the PDP10 version.
(defun loop-make-psetq (frobs)
(and frobs
(loop-make-setq
(list (car frobs)
(if (null (cddr frobs)) (cadr frobs)
`(prog1 ,(cadr frobs)
,(loop-make-psetq (cddr frobs))))))))
(defvar loop-use-system-destructuring?
nil)
(defvar loop-desetq-temporary)
; Do we want this??? It is, admittedly, useful...
;(defmacro loop-desetq (&rest x)
; (let ((loop-desetq-temporary nil))
; (let ((setq-form (loop-make-desetq x)))
; (if loop-desetq-temporary
; `((lambda (,loop-desetq-temporary) ,setq-form) nil)
; setq-form))))
(defun loop-make-desetq (x)
(if loop-use-system-destructuring?
(cons (do ((l x (cddr l))) ((null l) 'setq)
(or (and (not (null (car l))) (symbolp (car l)))
(return 'desetq)))
x)
(do ((x x (cddr x)) (r nil) (var) (val))
((null x) (and r (cons 'setq r)))
(setq var (car x) val (cadr x))
(cond ((and (not (atom var))
(not (atom val))
(not (and (member (car val) '(car cdr cadr cddr caar cdar))
(atom (cadr val)))))
(setq x (list* (or loop-desetq-temporary
(setq loop-desetq-temporary
(loop-gentemp 'loop-desetq-)))
val var loop-desetq-temporary (cddr x)))))
(setq r (nconc r (loop-desetq-internal (car x) (cadr x)))))))
(defun loop-desetq-internal (var val)
(cond ((null var) nil)
((atom var) (list var val))
(t (nconc (loop-desetq-internal (car var) `(car ,val))
(loop-desetq-internal (cdr var) `(cdr ,val))))))
(defun loop-make-setq (pairs)
(and pairs (loop-make-desetq pairs)))
(defparameter loop-keyword-alist ;clause introducers
'( (named loop-do-named)
(initially loop-do-initially)
(finally loop-do-finally)
(nodeclare loop-nodeclare)
(do loop-do-do)
(doing loop-do-do)
(return loop-do-return)
(collect loop-do-collect list)
(collecting loop-do-collect list)
(append loop-do-collect append)
(appending loop-do-collect append)
(nconc loop-do-collect nconc)
(nconcing loop-do-collect nconc)
(count loop-do-collect count)
(counting loop-do-collect count)
(sum loop-do-collect sum)
(summing loop-do-collect sum)
(maximize loop-do-collect max)
(minimize loop-do-collect min)
(always loop-do-always nil) ;Normal, do always
(never loop-do-always t) ; Negate the test on always.
(thereis loop-do-thereis)
(while loop-do-while nil while) ; Normal, do while
(until loop-do-while t until) ; Negate the test on while
(when loop-do-when nil when) ; Normal, do when
(if loop-do-when nil if) ; synonymous
(unless loop-do-when t unless) ; Negate the test on when
(with loop-do-with)))
(defparameter loop-iteration-keyword-alist
`((for loop-do-for)
(as loop-do-for)
(repeat loop-do-repeat)))
(defparameter loop-for-keyword-alist ;Types of FOR
'( (= loop-for-equals)
(first loop-for-first)
(in loop-list-stepper car)
(on loop-list-stepper nil)
(from loop-for-arithmetic from)
(downfrom loop-for-arithmetic downfrom)
(upfrom loop-for-arithmetic upfrom)
(below loop-for-arithmetic below)
(to loop-for-arithmetic to)
(being loop-for-being)))
(defvar loop-prog-names)
(defvar loop-macro-environment) ;Second arg to macro functions,
;passed to macroexpand.
(defvar loop-path-keyword-alist nil) ; PATH functions
(defvar loop-named-variables) ; see LOOP-NAMED-VARIABLE
(defvar loop-variables) ;Variables local to the loop
(defvar loop-declarations) ; Local dcls for above
(defvar loop-nodeclare) ; but don't declare these
(defvar loop-variable-stack)
(defvar loop-declaration-stack)
(defvar loop-desetq-crocks) ; see loop-make-variable
(defvar loop-desetq-stack) ; and loop-translate-1
(defvar loop-prologue) ;List of forms in reverse order
(defvar loop-wrappers) ;List of wrapping forms, innermost first
(defvar loop-before-loop)
(defvar loop-body) ;..
(defvar loop-after-body) ;.. for FOR steppers
(defvar loop-epilogue) ;..
(defvar loop-after-epilogue) ;So COLLECT's RETURN comes after FINALLY
(defvar loop-conditionals) ;If non-NIL, condition for next form in body
;The above is actually a list of entries of the form
;(cond (condition forms...))
;When it is output, each successive condition will get
;nested inside the previous one, but it is not built up
;that way because you wouldn't be able to tell a WHEN-generated
;COND from a user-generated COND.
;When ELSE is used, each cond can get a second clause
(defvar loop-when-it-variable) ;See LOOP-DO-WHEN
(defvar loop-never-stepped-variable) ; see LOOP-FOR-FIRST
(defvar loop-emitted-body?) ; see LOOP-EMIT-BODY,
; and LOOP-DO-FOR
(defvar loop-iteration-variables) ; LOOP-MAKE-ITERATION-VARIABLE
(defvar loop-iteration-variablep) ; ditto
(defvar loop-collect-cruft) ; for multiple COLLECTs (etc)
(defvar loop-source-code)
(defvar loop-duplicate-code nil) ; see LOOP-OPTIMIZE-DUPLICATED-CODE-ETC
;;;; Construct a value return
(defun loop-construct-return (form)
(if loop-prog-names
`(return-from ,(car loop-prog-names) ,form)
`(return ,form)))
;;;; Token Hackery
;Compare two "tokens". The first is the frob out of LOOP-SOURCE-CODE,
;the second a symbol to check against.
(defun loop-tequal (x1 x2)
(and (symbolp x1) (string= x1 x2)))
(defun loop-tassoc (kwd alist)
(and (symbolp kwd) (assoc kwd alist :test #'string=)))
(defun loop-tmember (kwd list)
(and (symbolp kwd) (member kwd list :test #'string=)))
(defmacro define-loop-macro (keyword)
"Makes KEYWORD, which is a LOOP keyword, into a Lisp macro that may
introduce a LOOP form. This facility exists mostly for diehard users of
a predecessor of LOOP. Unconstrained use is not advised, as it tends to
decrease the transportability of the code and needlessly uses up a
function name."
(or (eq keyword 'loop)
(loop-tassoc keyword loop-keyword-alist)
(loop-tassoc keyword loop-iteration-keyword-alist)
(loop-simple-error "not a loop keyword - define-loop-macro" keyword))
; #-kcl ; this doesn't work -- RGC
; `(progn
; (defmacro ,keyword (&whole whole-form &rest keywords-and-args &environment env)
; (declare (ignore keywords-and-args))
; (loop-translate whole-form env))
;; #+symbolics ;; tab correctly
;; (pushnew '(loop . zwei:indent-loop) zwei:*lisp-indent-offset-alist* :test #'equal)
; )
; #+kcl ; this doesn't work -- RGC
`(setf (macro-function ',keyword)
#'(lambda (whole-form &optional env) ;; RGC (added &optional)
(loop-translate whole-form env))))
(defmacro loop-finish ()
"Causes the iteration to terminate \"normally\", the same as implicit
termination by an iteration driving clause, or by use of WHILE or
UNTIL -- the epilogue code (if any) will be run, and any implicitly
collected result will be returned as the value of the LOOP."
'(go end-loop))
(defun loop-translate (x loop-macro-environment)
(loop-translate-1 x))
;;(let ((ccl::*warn-if-redefine-kernel* nil)
;; (ccl::*warn-if-redefine* nil))
(define-loop-macro loop)
(defun loop-end-testify (list-of-forms)
(if (null list-of-forms) nil
`(when ,(if (null (cdr (setq list-of-forms (nreverse list-of-forms))))
(car list-of-forms)
(cons 'or list-of-forms))
(go end-loop))))
(defun loop-optimize-duplicated-code-etc (&aux before after groupa groupb a b
lastdiff)
(do ((l1 (nreverse loop-before-loop) (cdr l1))
(l2 (nreverse loop-after-body) (cdr l2)))
((equal l1 l2)
(setq loop-body (nconc (delete nil l1) (nreverse loop-body))))
(push (car l1) before) (push (car l2) after))
(cond ((not (null loop-duplicate-code))
(setq loop-before-loop (nreverse (delete nil before))
loop-after-body (nreverse (delete nil after))))
(t (setq loop-before-loop nil loop-after-body nil
before (nreverse before) after (nreverse after))
(do ((bb before (cdr bb)) (aa after (cdr aa)))
((null aa))
(cond ((not (equal (car aa) (car bb))) (setq lastdiff aa))
((not (loop-simplep (car aa))) ;Mustn't duplicate
(return nil))))
(cond (lastdiff ;Down through lastdiff should be duplicated
(do nil (nil)
(and (car before) (push (car before) loop-before-loop))
(and (car after) (push (car after) loop-after-body))
(setq before (cdr before) after (cdr after))
(and (eq after (cdr lastdiff)) (return nil)))
(setq loop-before-loop (nreverse loop-before-loop)
loop-after-body (nreverse loop-after-body))))
(do ((bb (nreverse before) (cdr bb))
(aa (nreverse after) (cdr aa)))
((null aa))
(setq a (car aa) b (car bb))
(cond ((and (null a) (null b)))
((equal a b)
(loop-output-group groupb groupa)
(push a loop-body)
(setq groupb nil groupa nil))
(t (and a (push a groupa)) (and b (push b groupb)))))
(loop-output-group groupb groupa)))
(and loop-never-stepped-variable
(push `(setq ,loop-never-stepped-variable nil) loop-after-body))
nil)
(defun loop-output-group (before after)
(and (or after before)
(let ((v (or loop-never-stepped-variable
(setq loop-never-stepped-variable
(loop-make-variable
(loop-gentemp 'loop-iter-flag-) t nil)))))
(push (cond ((not before)
`(unless ,v (progn ,@after)))
((not after)
`(when ,v (progn ,@before)))
(t `(cond (,v ,@before) (t ,@after))))
loop-body))))
(defun loop-translate-1 (loop-source-code-form)
(let ((loop-source-code loop-source-code-form))
(and (eq (car loop-source-code) 'loop)
(setq loop-source-code (cdr loop-source-code)))
(do ((loop-iteration-variables nil)
(loop-iteration-variablep nil)
(loop-variables nil)
(loop-nodeclare nil)
(loop-named-variables nil)
(loop-declarations nil)
(loop-desetq-crocks nil)
(loop-variable-stack nil)
(loop-declaration-stack nil)
(loop-desetq-stack nil)
(loop-prologue nil)
(loop-wrappers nil)
(loop-before-loop nil)
(loop-body nil)
(loop-emitted-body? nil)
(loop-after-body nil)
(loop-epilogue nil)
(loop-after-epilogue nil)
(loop-conditionals nil)
(loop-when-it-variable nil)
(loop-never-stepped-variable nil)
(loop-desetq-temporary nil)
(loop-prog-names nil)
(loop-collect-cruft nil)
(keyword)
(tem)
(progvars))
((null loop-source-code)
(and loop-conditionals
(loop-simple-error "Hanging conditional in loop macro"
(caadar loop-conditionals)))
(loop-optimize-duplicated-code-etc)
(loop-bind-block)
(and loop-desetq-temporary (push loop-desetq-temporary progvars))
(setq tem `(block ,(car loop-prog-names)
(let ,progvars
(tagbody
,@(nreverse loop-prologue)
,@loop-before-loop
next-loop
,@loop-body
,@loop-after-body
(go next-loop)
(go end-loop)
end-loop
,@(nreverse loop-epilogue)
,@(nreverse loop-after-epilogue)))))
(do ((vars) (dcls) (crocks))
((null loop-variable-stack))
(setq vars (car loop-variable-stack)
loop-variable-stack (cdr loop-variable-stack)
dcls (car loop-declaration-stack)
loop-declaration-stack (cdr loop-declaration-stack)
tem (list tem))
(and (setq crocks (pop loop-desetq-stack))
(push (loop-make-desetq crocks) tem))
(and dcls (push (cons 'declare dcls) tem))
(cond ((do ((l vars (cdr l))) ((null l) nil)
(and (not (atom (car l)))
(or (null (caar l)) (not (symbolp (caar l))))
(return t)))
(setq tem `(let ,(nreverse vars) ,@tem)))
(t (let ((lambda-vars nil) (lambda-vals nil))
(do ((l vars (cdr l)) (v)) ((null l))
(cond ((atom (setq v (car l)))
(push v lambda-vars)
(push nil lambda-vals))
(t (push (car v) lambda-vars)
(push (cadr v) lambda-vals))))
(setq tem `((lambda ,lambda-vars ,@tem)
,@lambda-vals))))))
(do ((l loop-wrappers (cdr l))) ((null l))
(setq tem (append (car l) (list tem))))
tem)
;;The following commented-out code is what comes from the newest source
;; code in use in NIL. The code in use following it comes from about version
;; 803, that in use in symbolics release 6.1, for instance. To turn on the
;; implicit DO feature, switch them and fix loop-get-form to just pop the source.
(if (symbolp (setq keyword (car loop-source-code)))
(loop-pop-source)
(setq keyword 'do))
(if (setq tem (loop-tassoc keyword loop-keyword-alist))
(apply (cadr tem) (cddr tem))
(if (setq tem (loop-tassoc
keyword loop-iteration-keyword-alist))
(loop-hack-iteration tem)
(if (loop-tmember keyword '(and else))
; Alternative is to ignore it, ie let it go around to the
; next keyword...
(loop-simple-error
"secondary clause misplaced at top level in LOOP macro"
(list keyword (car loop-source-code)
(cadr loop-source-code)))
(loop-simple-error
"unknown keyword in LOOP macro" keyword))))
)))
(defun loop-bind-block ()
(cond ((not (null loop-variables))
(push loop-variables loop-variable-stack)
(push loop-declarations loop-declaration-stack)
(setq loop-variables nil loop-declarations nil)
(push loop-desetq-crocks loop-desetq-stack)
(setq loop-desetq-crocks nil))))
;Get FORM argument to a keyword. Read up to atom. PROGNify if necessary.
(defun loop-get-progn-1 ()
(do ((forms (list (loop-pop-source)) (cons (loop-pop-source) forms))
(nextform (car loop-source-code) (car loop-source-code)))
((atom nextform) (nreverse forms))))
(defun loop-get-progn ()
(let ((forms (loop-get-progn-1)))
(if (null (cdr forms)) (car forms) (cons 'progn forms))))
(defun loop-get-form (for)
;; Until implicit DO is installed, use the following. Then, replace it with
;; just loop-pop-source.
(let ((forms (loop-get-progn-1)))
(cond ((null (cdr forms)) (car forms))
(t (loop-warn
"The use of multiple forms with an implicit PROGN in this context
is considered obsolete, but is still supported for the time being.
If you did not intend to use multiple forms here, you probably omitted a DO.
If the use of multiple forms was intentional, put a PROGN in your code.
The offending clause"
(if (atom for) (cons for forms) (append for forms)))
(cons 'progn forms)))))
;;;This function takes a substitutable expression containing generic arithmetic
;;; of some form or another, and a data type name, and substitutes for the function
;;; any type-specific functions for that type in the implementation.
(defun loop-typed-arith (substitutable-expression data-type)
(declare (ignore data-type))
substitutable-expression)
(defvar loop-floating-point-types
'(flonum float short-float single-float double-float long-float))
(defun loop-typed-init (data-type)
(let ((tem nil))
(cond ((data-type? data-type) (initial-value data-type))
((loop-tmember data-type '(fixnum integer number)) 0)
((setq tem (car (loop-tmember
data-type loop-floating-point-types)))
(cond ((member tem '(flonum float)) 0.0)
(t (coerce 0 tem)))))))
(defun loop-make-variable (name initialization dtype)
(cond ((null name)
(cond ((not (null initialization))
(push (list (setq name (loop-gentemp 'loop-ignore-))
initialization)
loop-variables)
(push `(ignore ,name) loop-declarations))))
((atom name)
(cond (loop-iteration-variablep
(if (member name loop-iteration-variables)
(loop-simple-error
"Duplicated iteration variable somewhere in LOOP"
name)
(push name loop-iteration-variables)))
((assoc name loop-variables)
(loop-simple-error
"Duplicated var in LOOP bind block" name)))
(or (symbolp name)
(loop-simple-error "Bad variable somewhere in LOOP" name))
(loop-declare-variable name dtype)
; We use ASSOC on this list to check for duplications (above),
; so don't optimize out this list:
(push (list name (or initialization (loop-typed-init dtype)))
loop-variables))
(initialization
(cond (loop-use-system-destructuring?
(loop-declare-variable name dtype)
(push (list name initialization) loop-variables))
(t (let ((newvar (loop-gentemp 'loop-destructure-)))
(push (list newvar initialization) loop-variables)
; LOOP-DESETQ-CROCKS gathered in reverse order.
(setq loop-desetq-crocks
(list* name newvar loop-desetq-crocks))
(loop-make-variable name nil dtype)))))
(t (let ((tcar nil) (tcdr nil))
(if (atom dtype) (setq tcar (setq tcdr dtype))
(setq tcar (car dtype) tcdr (cdr dtype)))
(loop-make-variable (car name) nil tcar)
(loop-make-variable (cdr name) nil tcdr))))
name)
(defun loop-make-iteration-variable (name initialization dtype)
(let ((loop-iteration-variablep t))
(loop-make-variable name initialization dtype)))
(defun loop-declare-variable (name dtype)
(cond ((or (null name) (null dtype)) nil)
((symbolp name)
(cond ((member name loop-nodeclare))
((data-type? dtype)
(setq loop-declarations
(append (variable-declarations dtype name)
loop-declarations)))
(t (push `(type ,dtype ,name) loop-declarations))))
((consp name)
(cond ((consp dtype)
(loop-declare-variable (car name) (car dtype))
(loop-declare-variable (cdr name) (cdr dtype)))
(t (loop-declare-variable (car name) dtype)
(loop-declare-variable (cdr name) dtype))))
(t (loop-simple-error "can't hack this"
(list 'loop-declare-variable name dtype)))))
(defun loop-constantp (form)
(constantp form))
(defun loop-maybe-bind-form (form data-type?)
; Consider implementations which will not keep EQ quoted constants
; EQ after compilation & loading.
; Note FUNCTION is not hacked, multiple occurences might cause the
; compiler to break the function off multiple times!
; Hacking it probably isn't too important here anyway. The ones that
; matter are the ones that use it as a stepper (or whatever), which
; handle it specially.
(if (loop-constantp form) form
(loop-make-variable (loop-gentemp 'loop-bind-) form data-type?)))
(defun loop-optional-type ()
(let ((token (car loop-source-code)))
(and (not (null token))
(or (not (atom token))
(data-type? token)
(loop-tmember token '(fixnum integer number notype))
(loop-tmember token loop-floating-point-types))
(loop-pop-source))))
;Incorporates conditional if necessary
(defun loop-make-conditionalization (form)
(cond ((not (null loop-conditionals))
(rplacd (last (car (last (car (last loop-conditionals)))))
(list form))
(cond ((loop-tequal (car loop-source-code) 'and)
(loop-pop-source)
nil)
((loop-tequal (car loop-source-code) 'else)
(loop-pop-source)
;; If we are already inside an else clause, close it off
;; and nest it inside the containing when clause
(let ((innermost (car (last loop-conditionals))))
(cond ((null (cddr innermost))) ;Now in a WHEN clause, OK
((null (cdr loop-conditionals))
(loop-simple-error "More ELSEs than WHENs"
(list 'else (car loop-source-code)
(cadr loop-source-code))))
(t (setq loop-conditionals (cdr (nreverse loop-conditionals)))
(rplacd (last (car (last (car loop-conditionals))))
(list innermost))
(setq loop-conditionals (nreverse loop-conditionals)))))
;; Start a new else clause
(rplacd (last (car (last loop-conditionals)))
(list (list 't)))
nil)
(t ;Nest up the conditionals and output them
(do ((prev (car loop-conditionals) (car l))
(l (cdr loop-conditionals) (cdr l)))
((null l))
(rplacd (last (car (last prev))) (list (car l))))
(prog1 (car loop-conditionals)
(setq loop-conditionals nil)))))
(t form)))
(defun loop-pseudo-body (form &aux (z (loop-make-conditionalization form)))
(cond ((not (null z))
(cond (loop-emitted-body? (push z loop-body))
(t (push z loop-before-loop) (push z loop-after-body))))))
(defun loop-emit-body (form)
(setq loop-emitted-body? t)
(loop-pseudo-body form))
(defun loop-do-named ()
(let ((name (loop-pop-source)))
(unless (and name (symbolp name))
(loop-simple-error "Bad name for your loop construct" name))
;If this don't come first, LOOP will be confused about how to return
; from the prog when it tries to generate such code
(when (or loop-before-loop loop-body loop-after-epilogue)
(loop-simple-error "NAMED clause occurs too late" name))
(when (cdr (setq loop-prog-names (cons name loop-prog-names)))
(loop-simple-error "Too many names for your loop construct"
loop-prog-names))))
(defun loop-do-initially ()
(push (loop-get-progn) loop-prologue))
(defun loop-nodeclare (&aux (varlist (loop-pop-source)))
(or (null varlist)
(consp varlist)
(loop-simple-error "Bad varlist to nodeclare loop clause" varlist))
(setq loop-nodeclare (append varlist loop-nodeclare)))
(defun loop-do-finally ()
(push (loop-get-progn) loop-epilogue))
(defun loop-do-do ()
(loop-emit-body (loop-get-progn)))
(defun loop-do-return ()
(loop-pseudo-body (loop-construct-return (loop-get-form 'return))))
(defun loop-do-collect (type)
(let ((var nil) (form nil) (tem nil) (tail nil) (dtype nil) (cruft nil) (rvar nil)
(ctype (case type
((max min) 'maxmin)
((nconc list append) 'list)
((count sum) 'sum)
; ((member type '(max min)) 'maxmin)
(t (error "LOOP internal error: ~S is an unknown collecting keyword."
type)))))
(setq form (loop-get-form type) dtype (loop-optional-type))
(cond ((loop-tequal (car loop-source-code) 'into)
(loop-pop-source)
(setq rvar (setq var (loop-pop-source)))))
; CRUFT will be (varname ctype dtype var tail (optional tem))
(cond ((setq cruft (assoc var loop-collect-cruft))
(cond ((not (eq ctype (car (setq cruft (cdr cruft)))))
(loop-simple-error
"incompatible LOOP collection types"
(list ctype (car cruft))))
((and dtype (not (eq dtype (cadr cruft))))
;Conditional should be on data-type reality
(error "~A and ~A Unequal data types into ~A"
dtype (cadr cruft) (car cruft))))
(setq dtype (car (setq cruft (cdr cruft)))
var (car (setq cruft (cdr cruft)))
tail (car (setq cruft (cdr cruft)))
tem (cadr cruft))
(and (eq ctype 'maxmin)
(not (atom form)) (null tem)
(rplaca (cdr cruft)
(setq tem (loop-make-variable
(loop-gentemp 'loop-maxmin-)
nil dtype)))))
(t (unless dtype
(setq dtype (case type
(count 'fixnum)
((min max sum) 'number))))
(unless var
(push (loop-construct-return (setq var (loop-gentemp)))
loop-after-epilogue))
(loop-make-iteration-variable var nil dtype)
(cond ((eq ctype 'maxmin)
;Make a temporary.
(unless (atom form)
(setq tem (loop-make-variable
(loop-gentemp) nil dtype)))
;Use the tail slot of the collect database to hold a
; flag which says we have been around once already.
(setq tail (loop-make-variable
(loop-gentemp 'loop-maxmin-fl-) t nil)))
((eq ctype 'list)
;For dumb collection, we need both a tail and a flag var
; to tell us whether we have iterated.
(setq tail (loop-make-variable (loop-gentemp) nil nil)
tem (loop-make-variable (loop-gentemp) nil nil))))
(push (list rvar ctype dtype var tail tem)
loop-collect-cruft)))
(loop-emit-body
(case type
(count (setq tem `(setq ,var (,(loop-typed-arith '1+ dtype)
,var)))
(if (or (eq form t) (equal form ''t))
tem
`(when ,form ,tem)))
(sum `(setq ,var (,(loop-typed-arith '+ dtype) ,form ,var)))
((max min)
(let ((forms nil) (arglist nil))
; TEM is temporary, properly typed.
(and tem (setq forms `((setq ,tem ,form)) form tem))
(setq arglist (list var form))
(push (if (loop-tmember dtype '(fixnum flonum))
; no contagious arithmetic
`(when (or ,tail
(,(loop-typed-arith
(if (eq type 'max) '< '>)
dtype)
,@arglist))
(setq ,tail nil ,@arglist))
; potentially contagious arithmetic -- must use
; MAX or MIN so that var will be contaminated
`(setq ,var (cond (,tail (setq ,tail nil) ,form)
(t (,type ,@arglist)))))
forms)
(if (cdr forms) (cons 'progn (nreverse forms)) (car forms))))
(t (case type
(list (setq form (list 'list form)))
(append (or (and (not (atom form)) (eq (car form) 'list))
(setq form `(copy-list ,form)))))
(let ((q `(if ,tail (cdr (rplacd ,tail ,tem))
(setq ,var ,tem))))
(if (and (not (atom form)) (eq (car form) 'list) (cdr form))
`(setq ,tem ,form ,tail ,(loop-cdrify (cddr form) q))
`(when (setq ,tem ,form) (setq ,tail (last ,q))))))))))
(defun loop-cdrify (arglist form)
(do ((size (length arglist) (- size 4)))
((< size 4)
(if (zerop size) form
(list (cond ((= size 1) 'cdr) ((= size 2) 'cddr) (t 'cdddr))
form)))
(declare (type fixnum size))
(setq form (list 'cddddr form))))
(defun loop-do-while (negate? kwd &aux (form (loop-get-form kwd)))
(and loop-conditionals (loop-simple-error
"not allowed inside LOOP conditional"
(list kwd form)))
(loop-pseudo-body `(,(if negate? 'when 'unless)
,form (go end-loop))))
(defun loop-do-when (negate? kwd)
(let ((form (loop-get-form kwd)) (cond nil))
(cond ((loop-tequal (cadr loop-source-code) 'it)
;WHEN foo RETURN IT and the like
(setq cond `(setq ,(loop-when-it-variable) ,form))
(setq loop-source-code ;Plug in variable for IT
(list* (car loop-source-code)
loop-when-it-variable
(cddr loop-source-code))))
(t (setq cond form)))
(and negate? (setq cond `(not ,cond)))
(setq loop-conditionals (nconc loop-conditionals `((cond (,cond)))))))
(defun loop-do-with ()
(do ((var) (equals) (val) (dtype)) (nil)
(setq var (loop-pop-source) equals (car loop-source-code))
(cond ((loop-tequal equals '=)
(loop-pop-source)
(setq val (loop-get-form (list 'with var '=)) dtype nil))
((or (loop-tequal equals 'and)
(loop-tassoc equals loop-keyword-alist)
(loop-tassoc equals loop-iteration-keyword-alist))
(setq val nil dtype nil))
(t (setq dtype (loop-optional-type) equals (car loop-source-code))
(cond ((loop-tequal equals '=)
(loop-pop-source)
(setq val (loop-get-form (list 'with var dtype '=))))
((and (not (null loop-source-code))
(not (loop-tassoc equals loop-keyword-alist))
(not (loop-tassoc
equals loop-iteration-keyword-alist))
(not (loop-tequal equals 'and)))
(loop-simple-error "Garbage where = expected" equals))
(t (setq val nil)))))
(loop-make-variable var val dtype)
(if (not (loop-tequal (car loop-source-code) 'and)) (return nil)
(loop-pop-source)))
(loop-bind-block))
(defun loop-do-always (negate?)
(let ((form (loop-get-form 'always)))
(loop-emit-body `(,(if negate? 'when 'unless) ,form
,(loop-construct-return nil)))
(push (loop-construct-return t) loop-after-epilogue)))
;THEREIS expression
;If expression evaluates non-nil, return that value.
(defun loop-do-thereis ()
(loop-emit-body `(when (setq ,(loop-when-it-variable)
,(loop-get-form 'thereis))
,(loop-construct-return loop-when-it-variable))))
;;;; Hacks
(defun loop-simplep (expr)
(if (null expr) 0
(catch 'loop-simplep
(let ((ans (loop-simplep-1 expr)))
(declare (type fixnum ans))
(and (< ans 20.) ans)))))
(defvar loop-simplep
'(> < <= >= /= + - 1+ 1- ash equal atom setq prog1 prog2 and or = aref char schar sbit svref))
(defun loop-simplep-1 (x)
(let ((z 0))
(declare (type fixnum z))
(cond ((loop-constantp x) 0)
((atom x) 1)
((eq (car x) 'cond)
(do ((cl (cdr x) (cdr cl))) ((null cl))
(do ((f (car cl) (cdr f))) ((null f))
(setq z (+ (loop-simplep-1 (car f)) z 1))))
z)
((symbolp (car x))
(let ((fn (car x)) (tem nil))
(cond ((setq tem (get fn 'loop-simplep))
(if (typep tem 'fixnum) (setq z tem)
(setq z (funcall tem x) x nil)))
((member fn '(null not eq go return progn)))
((member fn '(car cdr)) (setq z 1))
((member fn '(caar cadr cdar cddr)) (setq z 2))
((member fn '(caaar caadr cadar caddr
cdaar cdadr cddar cdddr))
(setq z 3))
((member fn '(caaaar caaadr caadar caaddr
cadaar cadadr caddar cadddr
cdaaar cdaadr cdadar cdaddr
cddaar cddadr cdddar cddddr))
(setq z 4))
((member fn loop-simplep) (setq z 2))
(t (multiple-value-bind (new-form expanded-p)
(macroexpand-1 x loop-macro-environment)
(if expanded-p
(setq z (loop-simplep-1 new-form) x nil)
(throw 'loop-simplep nil)))))
(do ((l (cdr x) (cdr l))) ((null l))
(setq z (+ (loop-simplep-1 (car l)) 1 z)))
z))
(t (throw 'loop-simplep nil)))))
;;;; The iteration driver
(defun loop-hack-iteration (entry)
(do ((last-entry entry)
(source loop-source-code loop-source-code)
(pre-step-tests nil)
(steps nil)
(post-step-tests nil)
(pseudo-steps nil)
(pre-loop-pre-step-tests nil)
(pre-loop-steps nil)
(pre-loop-post-step-tests nil)
(pre-loop-pseudo-steps nil)
(tem) (data) (foo) (bar))
(nil)
; Note we collect endtests in reverse order, but steps in correct
; order. LOOP-END-TESTIFY does the nreverse for us.
(setq tem (setq data (apply (cadr entry) (cddr entry))))
(and (car tem) (push (car tem) pre-step-tests))
(setq steps (nconc steps (loop-copylist* (car (setq tem (cdr tem))))))
(and (car (setq tem (cdr tem))) (push (car tem) post-step-tests))
(setq pseudo-steps
(nconc pseudo-steps (loop-copylist* (car (setq tem (cdr tem))))))
(setq tem (cdr tem))
(and (or loop-conditionals loop-emitted-body?)
(or tem pre-step-tests post-step-tests pseudo-steps)
(let ((cruft (list (car entry) (car source)
(cadr source) (caddr source))))
(if loop-emitted-body?
(loop-simple-error
"Iteration is not allowed to follow body code" cruft)
(loop-simple-error
"Iteration starting inside of conditional in LOOP"
cruft))))
(or tem (setq tem data))
(and (car tem) (push (car tem) pre-loop-pre-step-tests))
(setq pre-loop-steps
(nconc pre-loop-steps (loop-copylist* (car (setq tem (cdr tem))))))
(and (car (setq tem (cdr tem))) (push (car tem) pre-loop-post-step-tests))
(setq pre-loop-pseudo-steps
(nconc pre-loop-pseudo-steps (loop-copylist* (cadr tem))))
(cond ((or (not (loop-tequal (car loop-source-code) 'and))
(and loop-conditionals
(not (loop-tassoc (cadr loop-source-code)
loop-iteration-keyword-alist))))
(setq foo (list (loop-end-testify pre-loop-pre-step-tests)
(loop-make-psetq pre-loop-steps)
(loop-end-testify pre-loop-post-step-tests)
(loop-make-setq pre-loop-pseudo-steps))
bar (list (loop-end-testify pre-step-tests)
(loop-make-psetq steps)
(loop-end-testify post-step-tests)
(loop-make-setq pseudo-steps)))
(cond ((not loop-conditionals)
(setq loop-before-loop (nreconc foo loop-before-loop)
loop-after-body (nreconc bar loop-after-body)))
(t ((lambda (loop-conditionals)
(push (loop-make-conditionalization
(cons 'progn (delete nil foo)))
loop-before-loop))
(mapcar #'(lambda (x) ;Copy parts that will get rplacd'ed
(cons (car x)
(mapcar #'(lambda (x) (loop-copylist* x)) (cdr x))))
loop-conditionals))
(push (loop-make-conditionalization
(cons 'progn (delete nil bar)))
loop-after-body)))
(loop-bind-block)
(return nil)))
(loop-pop-source) ; flush the "AND"
(setq entry (cond ((setq tem (loop-tassoc
(car loop-source-code)
loop-iteration-keyword-alist))
(loop-pop-source)
(setq last-entry tem))
(t last-entry)))))
;FOR variable keyword ..args..
(defun loop-do-for ()
(let ((var (loop-pop-source))
(data-type? (loop-optional-type))
(keyword (loop-pop-source))
(first-arg nil)
(tem nil))
(setq first-arg (loop-get-form (list 'for var keyword)))
(or (setq tem (loop-tassoc keyword loop-for-keyword-alist))
(loop-simple-error
"Unknown keyword in FOR or AS clause in LOOP"
(list 'for var keyword)))
(apply (cadr tem) var first-arg data-type? (cddr tem))))
(defun loop-do-repeat ()
(let ((var (loop-make-variable
(loop-gentemp 'loop-repeat-)
(loop-get-form 'repeat) 'fixnum)))
`((not (,(loop-typed-arith 'plusp 'fixnum) ,var))
() ()
(,var (,(loop-typed-arith '1- 'fixnum) ,var)))))
; Kludge the First
(defun loop-when-it-variable ()
(or loop-when-it-variable
(setq loop-when-it-variable
(loop-make-variable (loop-gentemp 'loop-it-) nil nil))))
(defun loop-for-equals (var val data-type?)
(cond ((loop-tequal (car loop-source-code) 'then)
;FOR var = first THEN next
(loop-pop-source)
(loop-make-iteration-variable var val data-type?)
`(() (,var ,(loop-get-form (list 'for var '= val 'then))) () ()
() () () ()))
(t (loop-make-iteration-variable var nil data-type?)
(let ((varval (list var val)))
(cond (loop-emitted-body?
(loop-emit-body (loop-make-setq varval))
'(() () () ()))
(`(() ,varval () ())))))))
(defun loop-for-first (var val data-type?)
(or (loop-tequal (car loop-source-code) 'then)
(loop-simple-error "found where THEN expected in FOR ... FIRST"
(car loop-source-code)))
(loop-pop-source)
(loop-make-iteration-variable var nil data-type?)
`(() (,var ,(loop-get-form (list 'for var 'first val 'then))) () ()
() (,var ,val) () ()))
(defun loop-list-stepper (var val data-type? fn)
(let ((stepper (cond ((loop-tequal (car loop-source-code) 'by)
(loop-pop-source)
(loop-get-form (list 'for var
(if (eq fn 'car) 'in 'on)
val 'by)))
(t '(function cdr))))
(var1 nil) (stepvar nil) (step nil) (et nil) (pseudo nil))
(setq step (if (or (atom stepper)
(not (member (car stepper) '(quote function))))
`(funcall ,(setq stepvar (loop-gentemp 'loop-fn-)))
(list (cadr stepper))))
(cond ((and (atom var)
;; (eq (car step) 'cdr)
(not fn))
(setq var1 (loop-make-iteration-variable var val data-type?)))
(t (loop-make-iteration-variable var nil data-type?)
(setq var1 (loop-make-variable
(loop-gentemp 'loop-list-) val nil))
(setq pseudo (list var (if fn (list fn var1) var1)))))
(rplacd (last step) (list var1))
(and stepvar (loop-make-variable stepvar stepper nil))
(setq stepper (list var1 step) et `(null ,var1))
(if (not pseudo) `(() ,stepper ,et () () () ,et ())
(if (eq (car step) 'cdr) `(,et ,pseudo () ,stepper)
`((null (setq ,@stepper)) () () ,pseudo ,et () () ,pseudo)))))
(defun loop-for-arithmetic (var val data-type? kwd)
; Args to loop-sequencer:
; indexv indexv-type variable? vtype? sequencev? sequence-type
; stephack? default-top? crap prep-phrases
(loop-sequencer
var (or data-type? #|'fixnum|#) nil nil nil nil nil nil `(for ,var ,kwd ,val)
(cons (list kwd val)
(loop-gather-preps
'(from upfrom downfrom to upto downto above below by)
nil))))
(defun loop-named-variable (name)
(let ((tem (loop-tassoc name loop-named-variables)))
(cond ((null tem) (loop-gentemp))
(t (setq loop-named-variables (delete tem loop-named-variables))
(cdr tem)))))
; Note: path functions are allowed to use loop-make-variable, hack
; the prologue, etc.
(defun loop-for-being (var val data-type?)
; FOR var BEING something ... - var = VAR, something = VAL.
; If what passes syntactically for a pathname isn't, then
; we trap to the DEFAULT-LOOP-PATH path; the expression which looked like
; a path is given as an argument to the IN preposition. Thus,
; by default, FOR var BEING EACH expr OF expr-2
; ==> FOR var BEING DEFAULT-LOOP-PATH IN expr OF expr-2.
(let ((tem nil) (inclusive? nil) (ipps nil) (each? nil) (attachment nil))
(if (or (loop-tequal val 'each) (loop-tequal val 'the))
(setq each? 't val (car loop-source-code))
(push val loop-source-code))
(cond ((and (setq tem (loop-tassoc val loop-path-keyword-alist))
(or each? (not (loop-tequal (cadr loop-source-code)
'and))))
;; FOR var BEING {each} path {prep expr}..., but NOT
;; FOR var BEING var-which-looks-like-path AND {ITS} ...
(loop-pop-source))
(t (setq val (loop-get-form (list 'for var 'being)))
(cond ((loop-tequal (car loop-source-code) 'and)
;; FOR var BEING value AND ITS path-or-ar
(or (null each?)
(loop-simple-error
"Malformed BEING EACH clause in LOOP" var))
(setq ipps `((of ,val)) inclusive? t)
(loop-pop-source)
(or (loop-tmember (setq tem (loop-pop-source))
'(its his her their each))
(loop-simple-error
"found where ITS or EACH expected in LOOP path"
tem))
(if (setq tem (loop-tassoc
(car loop-source-code)
loop-path-keyword-alist))
(loop-pop-source)
(push (setq attachment
`(in ,(loop-get-form
`(for ,var being \.\.\. in))))
ipps)))
((not (setq tem (loop-tassoc
(car loop-source-code)
loop-path-keyword-alist)))
; FOR var BEING {each} a-r ...
(setq ipps (list (setq attachment (list 'in val)))))
(t ; FOR var BEING {each} pathname ...
; Here, VAL should be just PATHNAME.
(loop-pop-source)))))
(cond ((not (null tem)))
((not (setq tem (loop-tassoc 'default-loop-path
loop-path-keyword-alist)))
(loop-simple-error "Undefined LOOP iteration path"
(cadr attachment))))
(setq tem (funcall (cadr tem) (car tem) var data-type?
(nreconc ipps (loop-gather-preps (caddr tem) t))
inclusive? (caddr tem) (cdddr tem)))
(and loop-named-variables
(loop-simple-error "unused USING variables" loop-named-variables))
; For error continuability (if there is any):
(setq loop-named-variables nil)
;; TEM is now (bindings prologue-forms . stuff-to-pass-back)
(do ((l (car tem) (cdr l)) (x)) ((null l))
(if (atom (setq x (car l)))
(loop-make-iteration-variable x nil nil)
(loop-make-iteration-variable (car x) (cadr x) (caddr x))))
(setq loop-prologue (nconc (reverse (cadr tem)) loop-prologue))
(cddr tem)))
(defun loop-gather-preps (preps-allowed crockp)
(do ((token (car loop-source-code) (car loop-source-code)) (preps nil))
(nil)
(cond ((loop-tmember token preps-allowed)
(push (list (loop-pop-source)
(loop-get-form `(for \... being \... ,token)))
preps))
((loop-tequal token 'using)
(loop-pop-source)
(or crockp (loop-simple-error
"USING used in illegal context"
(list 'using (car loop-source-code))))
(do ((z (car loop-source-code) (car loop-source-code)) (tem))
((atom z))
(and (or (atom (cdr z))
(not (null (cddr z)))
(not (symbolp (car z)))
(and (cadr z) (not (symbolp (cadr z)))))
(loop-simple-error
"bad variable pair in path USING phrase" z))
(cond ((not (null (cadr z)))
(and (setq tem (loop-tassoc
(car z) loop-named-variables))
(loop-simple-error
"Duplicated var substitition in USING phrase"
(list tem z)))
(push (cons (car z) (cadr z)) loop-named-variables)))
(loop-pop-source)))
(t (return (nreverse preps))))))
(defun loop-add-path (name data)
(setq loop-path-keyword-alist
(cons (cons name data)
(delete (loop-tassoc name loop-path-keyword-alist)
loop-path-keyword-alist
:test #'eq)))
nil)
(defmacro define-loop-path (names &rest cruft)
"(DEFINE-LOOP-PATH NAMES PATH-FUNCTION LIST-OF-ALLOWABLE-PREPOSITIONS
DATUM-1 DATUM-2 ...)
Defines PATH-FUNCTION to be the handler for the path(s) NAMES, which may
be either a symbol or a list of symbols. LIST-OF-ALLOWABLE-PREPOSITIONS
contains a list of prepositions allowed in NAMES. DATUM-i are optional;
they are passed on to PATH-FUNCTION as a list."
(setq names (if (atom names) (list names) names))
(let ((forms (mapcar #'(lambda (name) `(loop-add-path ',name ',cruft))
names)))
`(eval-when (eval load compile) ,@forms)))
(defun loop-sequencer (indexv indexv-type
variable? vtype?
sequencev? sequence-type?
stephack? default-top?
crap prep-phrases)
(let ((endform nil) (sequencep nil) (test nil)
(step ; Gross me out!
(1+ (or (loop-typed-init indexv-type) 0)))
(dir nil) (inclusive-iteration? nil) (start-given? nil) (limit-given? nil))
(and variable? (loop-make-iteration-variable variable? nil vtype?))
(do ((l prep-phrases (cdr l)) (prep) (form) (odir)) ((null l))
(setq prep (caar l) form (cadar l))
(cond ((loop-tmember prep '(of in))
(and sequencep (loop-simple-error
"Sequence duplicated in LOOP path"
(list variable? (car l))))
(setq sequencep t)
(loop-make-variable sequencev? form sequence-type?))
((loop-tmember prep '(from downfrom upfrom))
(and start-given?
(loop-simple-error
"Iteration start redundantly specified in LOOP sequencing"
(append crap l)))
(setq start-given? t)
(cond ((loop-tequal prep 'downfrom) (setq dir 'down))
((loop-tequal prep 'upfrom) (setq dir 'up)))
(loop-make-iteration-variable indexv form indexv-type))
((cond ((loop-tequal prep 'upto)
(setq inclusive-iteration? (setq dir 'up)))
((loop-tequal prep 'to)
(setq inclusive-iteration? t))
((loop-tequal prep 'downto)
(setq inclusive-iteration? (setq dir 'down)))
((loop-tequal prep 'above) (setq dir 'down))
((loop-tequal prep 'below) (setq dir 'up)))
(and limit-given?
(loop-simple-error
"Endtest redundantly specified in LOOP sequencing path"
(append crap l)))
(setq limit-given? t)
(setq endform (loop-maybe-bind-form form indexv-type)))
((loop-tequal prep 'by)
(setq step (if (loop-constantp form) form
(loop-make-variable
(loop-gentemp 'loop-step-by-)
form 'fixnum))))
(t ; This is a fatal internal error...
(loop-simple-error "Illegal prep in sequence path"
(append crap l))))
(and odir dir (not (eq dir odir))
(loop-simple-error
"Conflicting stepping directions in LOOP sequencing path"
(append crap l)))
(setq odir dir))
(and sequencev? (not sequencep)
(loop-simple-error "Missing OF phrase in sequence path" crap))
; Now fill in the defaults.
(setq step (list indexv step))
(cond ((member dir '(nil up))
(or start-given?
(loop-make-iteration-variable indexv 0 indexv-type))
(and (or limit-given?
(cond (default-top?
(loop-make-variable
(setq endform (loop-gentemp
'loop-seq-limit-))
nil indexv-type)
(push `(setq ,endform ,default-top?)
loop-prologue))))
(setq test (if inclusive-iteration? '(> . args)
'(>= . args))))
(push '+ step))
(t (cond ((not start-given?)
(or default-top?
(loop-simple-error
"Don't know where to start stepping"
(append crap prep-phrases)))
(loop-make-iteration-variable indexv 0 indexv-type)
(push `(setq ,indexv
(,(loop-typed-arith '1- indexv-type)
,default-top?))
loop-prologue)))
(cond ((and default-top? (not endform))
(setq endform (loop-typed-init indexv-type)
inclusive-iteration? t)))
(and (not (null endform))
(setq test (if inclusive-iteration? '(< . args)
'(<= . args))))
(push '- step)))
(and (and (numberp (caddr step)) (= (caddr step) 1)) ;Generic arith
(rplacd (cdr (rplaca step (if (eq (car step) '+) '1+ '1-)))
nil))
(rplaca step (loop-typed-arith (car step) indexv-type))
(setq step (list indexv step))
(setq test (loop-typed-arith test indexv-type))
(setq test (subst (list indexv endform) 'args test))
(and stephack? (setq stephack? `(,variable? ,stephack?)))
`(() ,step ,test ,stephack?
() () ,test ,stephack?)))
(defun loop-sequence-elements-path (path variable data-type
prep-phrases inclusive?
allowed-preps data)
allowed-preps ; unused
(let ((indexv (loop-named-variable 'index))
(sequencev (loop-named-variable 'sequence))
(fetchfun nil) (sizefun nil) (type nil) (default-var-type nil)
(crap `(for ,variable being the ,path)))
(cond ((not (null inclusive?))
(rplacd (cddr crap) `(,(cadar prep-phrases) and its ,path))
(loop-simple-error "Can't step sequence inclusively" crap)))
(setq fetchfun (car data)
sizefun (car (setq data (cdr data)))
type (car (setq data (cdr data)))
default-var-type (cadr data))
(list* nil nil ; dummy bindings and prologue
(loop-sequencer
indexv 'fixnum
variable (or data-type default-var-type)
sequencev type
`(,fetchfun ,sequencev ,indexv) `(,sizefun ,sequencev)
crap prep-phrases))))
(defmacro define-loop-sequence-path (path-name-or-names fetchfun sizefun
&optional sequence-type element-type)
"Defines a sequence iiteration path. PATH-NAME-OR-NAMES is either an
atomic path name or a list of path names. FETCHFUN is a function of
two arguments, the sequence and the index of the item to be fetched.
Indexing is assumed to be zero-origined. SIZEFUN is a function of
one argument, the sequence; it should return the number of elements in
the sequence. SEQUENCE-TYPE is the name of the data-type of the
sequence, and ELEMENT-TYPE is the name of the data-type of the elements
of the sequence."
`(define-loop-path ,path-name-or-names
loop-sequence-elements-path
(of in from downfrom to downto below above by)
,fetchfun ,sizefun ,sequence-type ,element-type))
;;;; Setup stuff
(mapc #'(lambda (x)
(mapc #'(lambda (y)
(setq loop-path-keyword-alist
(cons `(,y loop-sequence-elements-path
(of in from downfrom to downto
below above by)
,@(cdr x))
(delete (loop-tassoc
y loop-path-keyword-alist)
loop-path-keyword-alist
:test #'eq :count 1))))
(car x)))
'( ((element elements) elt length sequence)
;The following should be done by using ELEMENTS and type dcls...
((vector-element
vector-elements
array-element ;; Backwards compatibility -- DRM
array-elements)
aref length vector)
((simple-vector-element simple-vector-elements
simple-general-vector-element simple-general-vector-elements)
svref simple-vector-length simple-vector)
((bits bit bit-vector-element bit-vector-elements)
bit bit-vector-length bit-vector bit)
((simple-bit-vector-element simple-bit-vector-elements)
sbit simple-bit-vector-length simple-bit-vector bit)
((character characters string-element string-elements)
char length string string-char)
((simple-string-element simple-string-elements)
schar length simple-string string-char)
)
)
; (setf (macro-function 'lisp::loop) #'loop)
(pushnew 'loop *features*) ;; Common-Lisp says this is correct.
(pushnew :loop *features*) ;; But Lucid only understands this one.
(defun initial-value (x) x nil)
(defun variable-declarations (type &rest vars) type vars nil)
; Loop exists.
(provide 'loop)
